home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / hyperbole / kotl / kfile.el < prev    next >
Encoding:
Text File  |  1995-07-08  |  18.9 KB  |  553 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         kfile.el
  4. ;; SUMMARY:      Save and restore kotls from files.
  5. ;; USAGE:        GNU Emacs V19 Lisp Library
  6. ;; KEYWORDS:     outlines, wp
  7. ;;
  8. ;; AUTHOR:       Bob Weiner & Kellie Clark
  9. ;;
  10. ;; ORIG-DATE:    10/31/93
  11. ;; LAST-MOD:     23-Jun-95 at 12:02:23 by Bob Weiner
  12. ;;
  13. ;; This file is part of Hyperbole.
  14. ;; Available for use and distribution under the same terms as GNU Emacs.
  15. ;;
  16. ;; Copyright (C) 1993-1995, Free Software Foundation, Inc.
  17. ;; Developed with support from Motorola Inc.
  18. ;;
  19. ;; Pretty printing functions derived from:
  20. ;;    LCD Archive Entry:
  21. ;;      pp2|Randal L. Schwartz|merlyn@ora.com|Lisp pretty printer.|16-Sep-93|~/as-is/pp2.el.Z
  22. ;;      Copyright (c) 1989, 1993, Randal L. Schwartz  <merlyn@ora.com>
  23. ;;
  24. ;; DESCRIPTION:  
  25. ;; DESCRIP-END.
  26.  
  27. ;;; ************************************************************************
  28. ;;; Other required Elisp libraries
  29. ;;; ************************************************************************
  30.  
  31. (mapcar 'require '(kview kproperty kotl kotl-mode))
  32.  
  33. ;; Loads menus under non-tty InfoDock, XEmacs or Emacs19; does nothing
  34. ;; otherwise.
  35. (and (not (featurep 'kmenu)) hyperb:window-system
  36.      (or hyperb:lemacs-p hyperb:emacs19-p) (require 'kmenu))
  37.  
  38. ;;; ************************************************************************
  39. ;;; Public variables
  40. ;;; ************************************************************************
  41.  
  42. (defconst kfile:version "Kotl-3.0"
  43.   "Version number of persistent data format used for saving kotl data.")
  44.  
  45. ;;; ************************************************************************
  46. ;;; Entry Points
  47. ;;; ************************************************************************
  48.  
  49. ;;;###autoload
  50. (defun kfile:find (file-name)
  51.   "Find a file FILE-NAME containing a kotl or create one if none exists.
  52. Return the new kview."
  53.   (interactive
  54.    (list (kfile:read-name
  55.       "Find outline file [suffix = .kot(l)]: " nil)))
  56.   (let ((existing-file (file-exists-p file-name))
  57.     buffer view)
  58.     (and existing-file
  59.      (not (file-readable-p file-name))
  60.      (error
  61.       "(kfile:find): \"%s\" is not readable.  Check permissions."
  62.       file-name))
  63.     (setq buffer (find-file file-name))
  64.     (setq view (kfile:read buffer existing-file))
  65.     (or (eq major-mode 'kotl-mode) (kotl-mode))
  66.     view))
  67.  
  68. ;;;###autoload
  69. (defun kfile:view (file-name)
  70.   "View an existing kotl version-2 file FILE-NAME in a read-only mode."
  71.   (interactive
  72.    (list (kfile:read-name
  73.       "View outline file [suffix = .kot(l)]: " t)))
  74.   (let ((existing-file (file-exists-p file-name)))
  75.     (if existing-file
  76.     (if (not (file-readable-p file-name))
  77.         (error
  78.          "(kfile:view): \"%s\" is not readable.  Check permissions."
  79.          file-name))
  80.       (error "(kfile:view): \"%s\" does not exist."))
  81.     (view-file file-name))
  82.     (kfile:narrow-to-kcells)
  83.     (goto-char (point-min)))
  84.  
  85. ;;; ************************************************************************
  86. ;;; Public functions
  87. ;;; ************************************************************************
  88.  
  89. (defun kfile:create (buffer)
  90.   "Create a new kotl file attached to BUFFER, with a single empty level 1 kotl cell.
  91. Return file's kview."
  92.   (or buffer (setq buffer (current-buffer)))
  93.   (if (not (bufferp buffer))
  94.       (error "(kfile:create): Invalid buffer argument, %s" buffer))
  95.   (set-buffer buffer)
  96.   (if buffer-read-only
  97.       (error "(kfile:create): %s is read-only" buffer))
  98.   (let ((view (kview:create (buffer-name buffer)))
  99.     (standard-output (current-buffer)))
  100.     (widen)
  101.     (goto-char (point-min))
  102.     (prin1 kfile:version)
  103.     (princ " ;; file-format\n\^_\n")
  104.     ;; Ensure that last cell has two newlines after it so that
  105.     ;; kfile:insert-attributes finds it.
  106.     (princ "\n\n\^_\n")
  107.     (princ "\^_\n;; depth-first kcell attributes\n")
  108.     ;; Ensure that display is narrowed to cell region only.
  109.     (kfile:narrow-to-kcells)
  110.     (goto-char (point-min))
  111.     ;; 
  112.     ;; Always need at least one visible cell within a view.
  113.     ;; Insert initial empty cell.
  114.     (kview:add-cell "1" 1)
  115.     ;;
  116.     ;; Mark view unmodified and move to first cell.
  117.     (set-buffer-modified-p nil)
  118.     (goto-char (point-min))
  119.     (goto-char (kcell-view:start))
  120.     ;;
  121.     view))
  122.  
  123. ;;;###autoload
  124. (defun kfile:is-p ()
  125.   "Iff current buffer contains an unformatted kotl, return file format version string, else nil.
  126. Assume buffer has been widened to its full extent by the caller."
  127.   (let (ver-string)
  128.     (save-excursion
  129.       (goto-char (point-min))
  130.       (condition-case ()
  131.       (progn
  132.         (setq ver-string (read (current-buffer)))
  133.         (and (stringp ver-string) (string-match "^Kotl-" ver-string)
  134.          ver-string))
  135.     (error nil)))))
  136.  
  137. (defun kfile:read (buffer existing-file-p)
  138.   "Create a new kotl view by reading BUFFER or create an empty view when EXISTING-FILE-P is nil.
  139. Return the new view."
  140.   (let (ver-string)
  141.     (cond ((not (bufferp buffer))
  142.        (error "(kfile:read): Argument must be a buffer, '%s'." buffer))
  143.       ((not existing-file-p)
  144.        (kfile:create buffer))
  145.       ((progn
  146.          (set-buffer buffer)
  147.          (widen)
  148.          (not (setq ver-string (kfile:is-p))))
  149.        (error "(kfile:read): '%s' is not a kotl file." buffer))
  150.       ((equal ver-string "Kotl-3.0")
  151.        (kfile:read-v3 buffer))
  152.       ((equal ver-string "Kotl-2.0")
  153.        (kfile:read-v2 buffer))
  154.       ((equal ver-string "Kotl-1.0")
  155.        (error "(kfile:read): V1 koutlines are no longer supported"))
  156.       (t (error "(kfile:read): '%s' has unknown kotl version, %s."
  157.             buffer ver-string)))))
  158.  
  159. (defun kfile:read-v2 (buffer)
  160.   "Create a kotl view by reading kotl version-2 BUFFER.  Return the new view."
  161.   (let ((standard-input buffer)
  162.     cell-count label-type label-min-width label-separator
  163.     level-indent cell-data kotl-structure view kcell-list)
  164.     (widen)
  165.     (goto-char (point-min))
  166.     ;; Skip past cell contents here.
  167.     (search-forward "\n\^_" nil t 2)
  168.     ;; Read rest of file data.
  169.     (setq cell-count (read)
  170.       label-type (read)
  171.       label-min-width (read)
  172.       label-separator (read)
  173.       level-indent (read)
  174.       cell-data (read)
  175.       kotl-structure (read))
  176.     ;;
  177.     ;; kcell-list is a depth-first list of kcells to be attached to the cell
  178.     ;; contents within the kview down below.
  179.     (setq kcell-list (kfile:build-structure-v2 kotl-structure cell-data)
  180.       view (kview:create (buffer-name buffer) cell-count label-type
  181.                  level-indent label-separator label-min-width))
  182.     ;;
  183.     (kfile:narrow-to-kcells)
  184.     (goto-char (point-min))
  185.     ;;
  186.     ;; Add attributes to cells.
  187.     (kfile:insert-attributes-v2 view kcell-list)
  188.     ;;
  189.     ;; Mark view unmodified and move to first cell.
  190.     (set-buffer-modified-p nil)
  191.     (goto-char (point-min))
  192.     (goto-char (kcell-view:start))
  193.     view))
  194.  
  195. (defun kfile:read-v3 (buffer)
  196.   "Create a koutline view by reading version-3 BUFFER.  Return the new view."
  197.   (let ((standard-input buffer)
  198.     cell-count label-type label-min-width label-separator
  199.     level-indent cell-data view)
  200.     (widen)
  201.     (goto-char (point-min))
  202.     ;; Skip past cell contents here.
  203.     (search-forward "\n\^_" nil t 2)
  204.     ;; Read rest of file data.
  205.     (setq cell-count (read)
  206.       label-type (read)
  207.       label-min-width (read)
  208.       label-separator (read)
  209.       level-indent (read)
  210.       cell-data (read))
  211.     ;;
  212.     (setq view (kview:create (buffer-name buffer) cell-count label-type
  213.                  level-indent label-separator label-min-width))
  214.     ;;
  215.     (kfile:narrow-to-kcells)
  216.     (goto-char (point-min))
  217.     ;;
  218.     ;; Add attributes to cells.
  219.     (kfile:insert-attributes-v3 view cell-data)
  220.     ;;
  221.     ;; Mark view unmodified and move to first cell.
  222.     (set-buffer-modified-p nil)
  223.     (goto-char (point-min))
  224.     (goto-char (kcell-view:start))
  225.     view))
  226.  
  227. (defun kfile:update (&optional visible-only-p)
  228.   "Update kfile internal structure so that view is ready for saving to a file.
  229. Leave outline file expanded with structure data showing unless optional
  230. VISIBLE-ONLY-P is non-nil.  Signal an error if kotl is not attached to a file."
  231.   (let* ((top (kview:top-cell kview))
  232.      (file (kcell:get-attr top 'file))
  233.      (label-type (kview:label-type kview))
  234.      (label-min-width (kview:label-min-width kview))
  235.      (label-separator (kview:label-separator kview))
  236.      (level-indent (kview:level-indent kview))
  237.      ;; If this happens to be non-nil, it is virtually impossible to save
  238.      ;; a file, so ensure it is nil.
  239.      (debug-on-error))
  240.     (cond ((null file)
  241.        (error "(kfile:update): Current outline is not attached to a file."))
  242.       ((not (file-writable-p file))
  243.        (error "(kfile:update): File \"%s\" is not writable." file)))
  244.     (let* ((buffer-read-only)
  245.        (id-counter (kcell:get-attr top 'id-counter))
  246.        (kotl-data (make-vector (1+ id-counter) nil))
  247.        (standard-output (current-buffer))
  248.        (opoint (set-marker (make-marker) (point)))
  249.        (kcell-num 1)
  250.        cell)
  251.       ;;
  252.       ;; Prepare cell data for saving.
  253.       (kfile:narrow-to-kcells)
  254.       ;; Add blank lines separating cells where needed.
  255.       (kfile:extend-before-save)
  256.       (kview:map-tree
  257.     (function
  258.       (lambda (view)
  259.         (setq cell (kcell-view:cell))
  260.         (aset kotl-data
  261.           kcell-num
  262.           (kotl-data:create cell))
  263.         (setq kcell-num (1+ kcell-num))))
  264.     kview t)
  265.       ;; Save top cell, 0, last since above loop may increment the total
  266.       ;; number of cells counter stored in it, if any invalid cells are
  267.       ;; encountered. 
  268.       (aset kotl-data 0 (kotl-data:create top))
  269.       (setq id-counter (kcell:get-attr top 'id-counter))
  270.       ;;
  271.       (widen)
  272.       (goto-char (point-min))
  273.       (if (search-forward "\n\^_\n" nil t)
  274.       (delete-region (point-min) (match-end 0)))
  275.       (prin1 kfile:version)
  276.       (princ " ;; file-format\n\^_\n")
  277.       ;; Skip past cells.
  278.       (if (search-forward "\n\^_\n" nil t)
  279.       ;; Get rid of excess blank lines after last cell.
  280.       (progn (goto-char (match-beginning 0))
  281.          (skip-chars-backward "\n")
  282.          (delete-region (point) (point-max)))
  283.     (goto-char (point-max)))
  284.       ;; Ensure that last cell has two newlines after it so that
  285.       ;; kfile:insert-attributes finds it.
  286.       (princ "\n\n\^_\n")
  287.       (princ (format (concat
  288.               "%d ;; id-counter\n"
  289.               "%S ;; label-type\n%d ;; label-min-width\n"
  290.               "%S ;; label-separator\n%d ;; level-indent\n")
  291.              id-counter label-type label-min-width
  292.              label-separator level-indent))
  293.       (princ "\^_\n;; depth-first kcell attributes\n")
  294.       (kfile:pretty-print kotl-data)
  295.       ;;
  296.       ;; Don't re-narrow buffer by default since this is used in
  297.       ;; write-contents-hooks after save-buffer has widened buffer.  If
  298.       ;; buffer is narrowed here, only the narrowed portion will be saved to
  299.       ;; the file.  Narrow as an option since saving only the portion of the
  300.       ;; file visible in a view may be useful in some situations.
  301.       (if visible-only-p (kfile:narrow-to-kcells))
  302.       ;;
  303.       ;; Return point to its original position as given by the opoint marker.
  304.       (goto-char opoint)
  305.       (set-marker opoint nil)
  306.       nil)))
  307.  
  308. ;;; Next function is adapted from 'file-write' of GNU Emacs 19, copyright FSF,
  309. ;;; under the GPL.
  310. (defun kfile:write (file)
  311.   "Write current outline to FILE."
  312.   (interactive "FWrite outline file: ")
  313.   (if (or (null file) (string-equal file ""))
  314.       nil
  315.     ;; If arg is just a directory, use same file name, but in that directory.
  316.     (if (and (file-directory-p file) buffer-file-name)
  317.     (setq file (concat (file-name-as-directory file)
  318.                (file-name-nondirectory buffer-file-name))))
  319.     (kcell:set-attr (kview:top-cell kview) 'file file)
  320.     (set-visited-file-name file))
  321.   (set-buffer-modified-p t)
  322.   ;; This next line must come before the save-buffer since write-file-hooks
  323.   ;; can make use of it.
  324.   (kview:set-buffer-name kview (buffer-name))
  325.   (save-buffer))
  326.  
  327. ;;; ************************************************************************
  328. ;;; Private functions
  329. ;;; ************************************************************************
  330.  
  331. (defun kfile:build-structure-v2 (kotl-structure cell-data)
  332.   "Build cell list from the KOTL-STRUCTURE and its CELL-DATA.
  333. Assumes all arguments are valid.  CELL-DATA is a vector of cell fields read
  334. from a koutline file.
  335.  
  336. Return list of outline cells in depth first order.  Invisible top cell is not
  337. included in the list."
  338.   (let ((stack) (sibling-p) (cell-list) func cell)
  339.     (mapcar
  340.      (function
  341.       (lambda (item)
  342.     (setq func (cdr (assoc item
  343.                    (list
  344.                 (cons "\("
  345.                       (function
  346.                        (lambda ()
  347.                      (setq stack (cons sibling-p stack)
  348.                            sibling-p nil))))
  349.                 (cons "\)" 
  350.                       (function
  351.                        (lambda ()
  352.                      (setq sibling-p (car stack)
  353.                            stack (cdr stack)))))))))
  354.     (cond (func (funcall func))
  355.           ;; 0th cell was created with kview:create.
  356.           ((equal item 0) nil)
  357.           (t (setq cell (kotl-data:to-kcell-v2 (aref cell-data item))
  358.                cell-list (cons cell cell-list)
  359.                sibling-p t)
  360.          ))))
  361.      kotl-structure)
  362.     (nreverse cell-list)))
  363.  
  364. (defun kfile:extend-before-save ()
  365.   "Temporarily add blank lines between all visible and invisible cells in current kview."
  366.   (interactive "*")
  367.   (let ((modified-p (buffer-modified-p))
  368.     end)
  369.     (save-excursion
  370.       (goto-char (point-min))
  371.       (while (and (setq end (kproperty:next-single-change (point) 'kcell-end))
  372.           (progn
  373.             (goto-char end)
  374.             (insert (following-char))
  375.             (if (= (point) (point-max))
  376.             nil
  377.               (forward-char 2)
  378.               t))))
  379.       (set-buffer-modified-p modified-p))))
  380.  
  381. (defun kfile:insert-attributes-v2 (kview kcell-list)
  382.   "Set cell attributes within kview for each element in KCELL-LIST.
  383. Assumes all cell contents are already in kview and that no cells are
  384. hidden."
  385.   (let (buffer-read-only)
  386.     (while
  387.     (progn
  388.       (skip-chars-forward "\n")
  389.       ;; !!! Won't work if label-type is 'no.
  390.       ;; Here we search past the cell identifier
  391.       ;; for the location at which to place cell properties.
  392.       ;; Be sure not to skip past a period which may terminate the label.
  393.       (if (re-search-forward "[A-Za-z0-9]\\(\\.?[A-Za-z0-9]\\)*" nil t)
  394.           (progn
  395.         (kproperty:set 'kcell (car kcell-list))
  396.         (setq kcell-list (cdr kcell-list))))
  397.       (search-forward "\n\n" nil t)))))
  398.  
  399. (defun kfile:insert-attributes-v3 (kview kcell-vector)
  400.   "Set cell attributes within kview for each element in KCELL-VECTOR.
  401. Assumes all cell contents are already in kview and that no cells are
  402. hidden."
  403.   (let ((kcell-num 1)
  404.     (buffer-read-only))
  405.     (while
  406.     (progn
  407.       (skip-chars-forward "\n")
  408.       ;; !!! Won't work if label-type is 'no.
  409.       ;; Here we search past the cell identifier
  410.       ;; for the location at which to place cell properties.
  411.       ;; Be sure not to skip past a period which may terminate the label.
  412.       (if (re-search-forward "[A-Za-z0-9]\\(\\.?[A-Za-z0-9]\\)*" nil t)
  413.           (progn
  414.         (kproperty:set 'kcell
  415.                    (kotl-data:to-kcell-v3
  416.                 (aref kcell-vector kcell-num)))
  417.         (setq kcell-num (1+ kcell-num))))
  418.       (search-forward "\n\n" nil t)))))
  419.  
  420. (defun kfile:narrow-to-kcells ()
  421.   "Narrow kotl file to kcell section only."
  422.   (interactive)
  423.   (if (kview:is-p kview)
  424.       (let ((start-text) (end-text))
  425.     (save-excursion
  426.       (widen)
  427.       (goto-char (point-min))
  428.       ;; Skip to start of kcells.
  429.       (if (search-forward "\n\^_" nil t)
  430.           (setq start-text (1+ (match-end 0))))
  431.       ;; Skip past end of kcells.
  432.       (if (and start-text (search-forward "\n\^_" nil t))
  433.           (setq end-text (1+ (match-beginning 0))))
  434.       (if (and start-text end-text)
  435.           (progn (narrow-to-region start-text end-text)
  436.              (goto-char (point-min)))
  437.         (error
  438.          "(kfile:narrow-to-kcells): Cannot find start or end of kcells"))
  439.       ))))
  440.  
  441. (defun kfile:print-to-string (object)
  442.   "Return a string containing OBJECT, any Lisp object, in pretty-printed form.
  443. Quoting characters are used when needed to make output that `read' can
  444. handle, whenever this is possible."
  445.   (save-excursion
  446.     (set-buffer (get-buffer-create " kfile:print-to-string"))
  447.     (let ((emacs-lisp-mode-hook)
  448.       (buffer-read-only))
  449.       (erase-buffer)
  450.       (unwind-protect
  451.       (progn
  452.         (emacs-lisp-mode)
  453.         (let ((print-escape-newlines kfile:escape-newlines))
  454.           (prin1 object (current-buffer)))
  455.         (goto-char (point-min))
  456.         (while (not (eobp))
  457.           ;; (message "%06d" (- (point-max) (point)))
  458.           (cond
  459.            ((looking-at "\\s\(")
  460.         (while (looking-at "\\s(")
  461.           (forward-char 1)))
  462.            ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)")
  463.              (> (match-beginning 1) 1)
  464.              (= ?\( (char-after (1- (match-beginning 1))))
  465.              ;; Make sure this is a two-element list.
  466.              (save-excursion
  467.                (goto-char (match-beginning 2))
  468.                (forward-sexp)
  469.                ;; (looking-at "[ \t]*\)")
  470.                ;; Avoid mucking with match-data; does this test work?
  471.                (char-equal ?\) (char-after (point)))))
  472.         ;; -1 gets the paren preceding the quote as well.
  473.         (delete-region (1- (match-beginning 1)) (match-end 1))
  474.         (insert "'")
  475.         (forward-sexp 1)
  476.         (if (looking-at "[ \t]*\)")
  477.             (delete-region (match-beginning 0) (match-end 0))
  478.           (error "Malformed quote"))
  479.         (backward-sexp 1))          
  480.            ((condition-case ()
  481.             (prog1 t (down-list 1))
  482.           (error nil))
  483.         (backward-char 1)
  484.         (skip-chars-backward " \t")
  485.         (delete-region
  486.          (point)
  487.          (progn (skip-chars-forward " \t") (point)))
  488.         (if (not (char-equal ?' (char-after (1- (point)))))
  489.             (insert ?\n)))
  490.            ((condition-case ()
  491.             (prog1 t (up-list 1))
  492.           (error nil))
  493.         (while (looking-at "\\s)")
  494.           (forward-char 1))
  495.         (skip-chars-backward " \t")
  496.         (delete-region
  497.          (point)
  498.          (progn (skip-chars-forward " \t") (point)))
  499.         (if (not (char-equal ?' (char-after (1- (point)))))
  500.             (insert ?\n)))
  501.            (t (goto-char (point-max)))))
  502.         (goto-char (point-min))
  503.         (indent-sexp)
  504.         (buffer-string))
  505.     (kill-buffer (current-buffer))))))
  506.  
  507. (defun kfile:pretty-print (object &optional stream)
  508.   "Output the pretty-printed representation of OBJECT, any Lisp object.
  509. Quoting characters are printed when needed to make output that `read'
  510. can handle, whenever this is possible.
  511. Output stream is STREAM, or value of `standard-output' (which see)."
  512.   (princ (kfile:print-to-string object) (or stream standard-output)))
  513.  
  514. (defun kfile:read-name (prompt existing-p)
  515.   "PROMPT for and read a kotl file name.  EXISTING-P means must exist."
  516.   (let ((valid-suffix-regexp (car (rassq 'kotl-mode auto-mode-alist)))
  517.     (filename))
  518.     (while (not filename)
  519.       (setq filename (read-file-name prompt nil nil existing-p))
  520.       (if (and valid-suffix-regexp
  521.            (or (null filename)
  522.            (not (string-match valid-suffix-regexp filename))))
  523.       (progn (ding) (setq filename nil))))
  524.     filename))
  525.  
  526. (defun kfile:shorten-after-saving ()
  527.   "Remove blank lines which were added between cells during saving of the outline.
  528. Used in 'after-save-hooks'."
  529.   (interactive "*")
  530.   (if (kview:is-p kview)
  531.       (let ((modified-p (buffer-modified-p))
  532.         end)
  533.     (save-excursion
  534.       (goto-char (point-min))
  535.       (while (and (setq end (kproperty:next-single-change (point) 'kcell-end))
  536.               (progn
  537.             (goto-char end)
  538.             (delete-char 1)
  539.             (if (= (point) (point-max))
  540.                 nil
  541.               (forward-char 1)
  542.               t))))
  543.       (set-buffer-modified-p modified-p)))))
  544.  
  545. ;;; ************************************************************************
  546. ;;; Private variables
  547. ;;; ************************************************************************
  548.  
  549. (defvar kfile:escape-newlines t 
  550.   "Value of print-escape-newlines used by 'kfile:print-to-string' function.")
  551.  
  552. (provide 'kfile)
  553.